home *** CD-ROM | disk | FTP | other *** search
/ Mac Mania 2 / MacMania 2.toast / Demo's / Tools&Utilities / Programming / HELP language 1.4 / Help Files / Compilation / Thunks < prev   
Encoding:
Text File  |  1991-04-26  |  3.6 KB  |  129 lines  |  [TEXT/Help]
  1. ;••• Thunks •••
  2.  
  3. (define (thunk? x) (and (cons? x) (eq? (0 x) 'thunk)))
  4.  
  5. (defmacro (info th)
  6.     `(1 ,th))
  7. (defmacro (code th)
  8.     `(2 ,th))
  9. (defmacro (source th)
  10.     `(3 ,th))
  11.  
  12. ;pour le moment, les infos sont limitées à
  13. ;necessaires  modifié strict(nec mod str)
  14.  
  15. (defmacro (minfo n m s)
  16.     `(cell ,n ,m ,s))
  17.  
  18. (defmacro (nec th)
  19.     `(0 (info ,th)))
  20.  
  21. (defmacro (mod th)
  22.     `(1 (info ,th)))
  23.  
  24. (defmacro (str th)
  25.     `(2 (info ,th)))
  26.  
  27. (define (necessite th r)
  28.     (memq? r (nec th)))
  29.  
  30. (define everything '(r0 r1 r2 a0 a1))
  31.  
  32. (define (modifie th r)
  33.     (memq? r (mod th)))
  34.  
  35. (define (empty-thunk)
  36.     (mthunk () (minfo () () ()) ()))
  37.  
  38. (define (empty-pthunk)
  39.     (mpthunk () (minfo () () ())))
  40.  
  41. (defmacro (mthunk c i s)
  42.    `(list 'thunk ,i ,c ,s))
  43.  
  44. (defmacro (mpthunk c i)
  45.    `(list 'thunk ,i ,c))
  46.  
  47. (define (add-source t s)
  48.    (mthunk (code t) (info t) s))
  49.  
  50. (define (add-strict v)
  51.   (mpthunk () (minfo () () (list v))))
  52.   
  53. (define (add-info n m s)
  54.   (mpthunk () (minfo n m s)))
  55.  
  56. ;••• Fusion de 2 segments de code •••
  57.  
  58.  
  59. (define (append2th t1 t2)
  60.     (mthunk (append (code t1)(code t2))
  61.             (minfo (union-set (nec t1)
  62.                           (differ-set (nec t2)
  63.                                 (mod t1)))
  64.                    (union-set (mod t1)
  65.                           (mod t2))
  66.                    (union-set (str t1)
  67.                           (str t2)))
  68.             (append (source t1)
  69.                     (source t2))))
  70.  
  71. (define (append2pth t1 t2)
  72.     (mpthunk (append (code t1)(code t2))
  73.              (minfo (union-set (nec t1)
  74.                           (differ-set (nec t2)
  75.                                 (mod t1)))
  76.                    (union-set (mod t1)
  77.                           (mod t2))
  78.                    (union-set (str t1)
  79.                           (str t2)))))
  80.  
  81. ;••• fusion de n segments de code •••
  82.  
  83.  
  84. (define (appendths | ts)
  85.     (cond (null? ts) (empty-thunk)
  86.           (append2th (0 ts) (apply appendths (-1 ts)))))
  87.  
  88. (define (appendpths | ts)
  89.     (cond (null? ts) (empty-pthunk)
  90.           (append2pth (0 ts) (apply appendpths (-1 ts)))))
  91.  
  92. ;••• alternative 2 partial thunks… les registres nec sont l'union des 2 •••
  93.  
  94. (define (undes2pth t1 t2)
  95.     (mpthunk (append (code t1)(code t2))
  96.              (minfo (union-set (nec t1)
  97.                            (nec t2))
  98.                     (union-set (mod t1)
  99.                            (mod t2))
  100.                     (inter-set (str t1)
  101.                            (str t2)))))
  102.  
  103. ;••• preserve le registre r si T1 le modifie et T2 necessite •••
  104.  
  105. (define (preservepth r t1 t2)
  106.     (cond (and (necessite t2 r)
  107.              (modifie t1 r))
  108.         (append2pth (addpushpop r t1) t2)
  109.         (append2pth t1 t2)))
  110.  
  111. (define (addpushpop r t)
  112.   (cond (memq? r '(d0 d1 lp)) (appendpths (synt-move "L" r '(- SP))
  113.                                           t
  114.                                           (synt-move "L" '(SP +) r))
  115.         (appendpths (synt-move "L" r '(LP +))
  116.                     t
  117.                     (synt-move "L" '(- LP) r))))
  118.  
  119. ;••• Dummy thunks •••
  120.  
  121. (define thunk:getablock (mthunk () (minfo '(d0) '(a0) ()) 'GetABlock))
  122. (define thunk:lookvarval (mthunk () (minfo '(r0 r2) '(r0) ()) 'LookVarVal))
  123. (define thunk:valvarset (mthunk () (minfo '(a0 r0) '(m) ()) 'ValVarSet))
  124. (define thunk:applyit (mthunk () (minfo '(d1) '(r0 r1 r2 a0 a1 d0 d1) ()) 'ApplyStack))
  125. (define thunk:susp&apply (mthunk () (minfo '(d1) '(r0 r1 r2 a0 a1 d0 d1) ()) 'Suspend&Apply))
  126. (define thunk:holda0 (mthunk () (minfo '(a0) '(r0 r1 r2 a1 d0 d1) ()) 'HoldA0))
  127. (define thunk:holda1 (mthunk () (minfo '(a1) '(r0 r1 r2 a0 d0 d1) ()) 'HoldA1))
  128. (define thunk:holdr0 (mthunk () (minfo '(r0) '(a0 r1 r2 a1 d0 d1) ()) 'HoldR0))
  129.